home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / pas_0593.zip / DOTSPIN.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-30  |  3KB  |  112 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 642 of 728
  3. From : Sean Palmer                         1:104/123.0          07 May 93  15:13
  4. To   : All
  5. Subj : DotSpin
  6. ────────────────────────────────────────────────────────────────────────────────
  7. Here's a little trippy program I invented a long time ago on an Apple II
  8. and just recently ported to the IBM.
  9.  
  10. Would work great as a screen saver!}
  11.  
  12. program dotspin;
  13.  
  14. var inPort1:word;
  15. procedure waitRetrace;assembler;asm
  16.  mov dx,inPort1; {find crt status reg (input port #1)}
  17. @L1: in al,dx; test al,8; jnz @L1;  {wait for no v retrace}
  18. @L2: in al,dx; test al,8; jz @L2; {wait for v retrace}
  19.  end;
  20.  
  21. const
  22.  tableWriteIndex=$3C8;
  23.  tableDataRegister=$3C9;
  24.  
  25. procedure setColor(color,r,g,b:byte);assembler;asm {set DAC color}
  26.  mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
  27.  mov al,r; out dx,al; mov al,g; out dx,al; mov al,b;out dx,al;
  28.  end; {write index now points to next color}
  29.  
  30. {plot a pixel in mode $13}
  31. procedure plot(x,y:word);Inline(
  32.   $5E/                   { pop si  ;y}
  33.   $5F/                   { pop di  ;x}
  34.   $B8/$00/$A0/           { mov ax,$A000}
  35.   $8E/$C0/               { mov es,ax}
  36.   $B8/$40/$01/           { mov ax,320}
  37.   $F7/$E6/               { mul si}
  38.   $01/$C7/               { add di,ax}
  39.   $26/$F6/$15);          {es: not byte[di]}
  40.  
  41. procedure plot4(x,y:word);const f=60;begin
  42.  plot(x+f,y);
  43.  plot(199+f-x,199-y);
  44.  plot(199+f-y,x);
  45.  plot(y+f,199-x);
  46.  end;
  47.  
  48. procedure click;assembler;asm
  49.  in al,$61; xor al,2; out $61,al;
  50.  end;
  51.  
  52. const nDots=21;
  53.  
  54. var
  55.  dot:array[0..nDots-1]of record
  56.   x,y,sx,sy:integer;
  57.   end;
  58.  
  59. function colorFn(x:integer):byte;begin
  60.  colorFn:=63-(abs(100-x)div 2);
  61.  end;
  62.  
  63. procedure moveDots;var i:word;begin
  64.  for i:=0 to nDots-1 do with dot[i] do begin
  65.   plot4(x,y);
  66.   inc(x,sx);inc(y,sy);
  67.   if(word(x)>200)then begin
  68.    sx:=-sx;inc(x,sx);click;
  69.    end;
  70.   if(word(y)>199)then begin
  71.    sy:=-sy;inc(y,sy);click;
  72.    end;
  73.   plot4(x,y);
  74.   end;
  75.  waitRetrace;waitRetrace;waitRetrace;{waitRetrace;}
  76.  setcolor(255,colorFn(dot[0].x),colorFn(dot[3].x),colorFn(dot[6].x));
  77.  end;
  78.  
  79. procedure drawdots;var i:word;begin
  80.  for i:=0 to nDots-1 do with dot[i] do plot4(x,y);
  81.  end;
  82.  
  83. procedure initDots;var i,j,k:word;begin
  84.  j:=1;k:=1;
  85.  for i:=0 to nDots-1 do with dot[i] do begin
  86.   x:=100;y:=99;
  87.   sx:=j;sy:=k;
  88.   inc(j);if j>=k then begin j:=1;inc(k); end;
  89.   end;
  90.  end;
  91.  
  92. function readKey:char;Inline(
  93.   $B4/$07/               {mov ah,7}
  94.   $CD/$21);              {int $21}
  95.  
  96. function keyPressed:boolean;Inline(
  97.   $B4/$0B/               {mov ah,$B}
  98.   $CD/$21/               {int $21}
  99.   $24/$FE);              {and al,$FE}
  100.  
  101. begin
  102.  inPort1:=memw[$40:$63]+6;
  103.  port[$61]:=port[$61]and (not 1);
  104.  setcolor(255,60,60,63);
  105.  initDots;
  106.  asm mov ax,$13; int $10; end;
  107.  drawDots;
  108.  repeat moveDots until keypressed;
  109.  readkey;
  110.  drawDots;
  111.  asm mov ax,3; int $10; end;
  112.  end.